home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 1463.ZIP / DRAW-2D.ARC / GRMAT.PAS < prev    next >
Pascal/Delphi Source File  |  1986-10-29  |  4KB  |  147 lines
  1. PROCEDURE INITSTK;
  2.    VAR
  3.      I,J:INTEGER;
  4.      XWRAT,YWRAT,XWSHFT,YWSHFT:REAL;
  5.    BEGIN
  6.      FOR I := 1 TO 3 DO
  7.         FOR J := 1 TO 3 DO
  8.             CLRMAT[I,J] := 0.0;
  9.      IDMAT := CLRMAT;
  10.      FOR I := 1 TO 3 DO
  11.             IDMAT[I,I] := 1.0;
  12.      ROTMAT := CLRMAT;
  13.      SCALEMAT := CLRMAT;
  14.      TRANSMAT := CLRMAT;
  15.      WORLDMAT := IDMAT;
  16.      XWRAT := (XVMAX-XVMIN)/(XWMAX-XWMIN);
  17.      YWRAT := (YVMAX-YVMIN)/(YWMAX-YWMIN);
  18.      XWSHFT := XVMIN - (XWMIN*XWRAT);
  19.      YWSHFT := YVMIN - (YWMIN*YWRAT);
  20.      WORLDMAT[1,1] := XWRAT;
  21.      WORLDMAT[2,2] := YWRAT;
  22.      WORLDMAT[3,1] := XWSHFT;
  23.      WORLDMAT[3,2] := YWSHFT;
  24.      TEMPMAT  := CLRMAT;
  25.      FOR I := 1 TO 10 DO
  26.          STKMAT[I] := CLRMAT;
  27.      STKMAT[1] := WORLDMAT;
  28.      STKPTR := 2;
  29.    END;
  30. PROCEDURE MULMAT(A,B:MATRIX; VAR C:MATRIX);
  31.    VAR
  32.     I,J,K:INTEGER;
  33.    BEGIN
  34.     TEMPMAT := CLRMAT;
  35.     FOR I := 1 TO 3 DO
  36.         FOR K := 1 TO 3 DO
  37.               FOR J := 1 TO 3 DO
  38.                   TEMPMAT[I,K] := TEMPMAT[I,K] + A[I,J]*B[J,K];
  39.     C := TEMPMAT;
  40.    END;
  41. PROCEDURE MULVEC(VAR V:VECTOR; A:MATRIX);
  42.    VAR
  43.      J,K:INTEGER;
  44.      P:VECTOR;
  45.    BEGIN
  46.      FOR K := 1 TO 3 DO
  47.        BEGIN
  48.          P[K] := 0.0;
  49.          FOR J := 1 TO 3 DO
  50.              P[K] := P[K] + V[J]*A[J,K];
  51.        END;
  52.      IF P[3] = 0 THEN
  53.         BEGIN
  54.           P[1] := XDMAX;
  55.           P[2] := YDMAX;
  56.           P[3] := 1.0;
  57.         END
  58.       ELSE
  59.         BEGIN
  60.           P[1] := P[1]/P[3];
  61.           P[2] := P[2]/P[3];
  62.           P[3] := 1.0;
  63.         END;
  64.      V := P;
  65.    END;
  66. PROCEDURE PUSHID(VAR CODE:INTEGER);
  67.    BEGIN
  68.      CODE := 0;
  69.      IF STKPTR < 11 THEN
  70.         BEGIN
  71.           STKMAT[STKPTR] := IDMAT;
  72.           STKPTR := STKPTR + 1;
  73.         END
  74.       ELSE
  75.         CODE := 1;     (* NO ROOM TO PUSH *)
  76.    END;
  77. PROCEDURE POPMAT(VAR CODE:INTEGER);
  78.    BEGIN
  79.      CODE := 0;
  80.      IF STKPTR > 1 THEN
  81.         BEGIN
  82.           STKMAT[STKPTR] := CLRMAT;
  83.           STKPTR := STKPTR - 1;
  84.         END
  85.       ELSE
  86.         CODE := 1;     (* NOTHING TO POP *)
  87.    END;
  88. PROCEDURE TRANSLAT(DELTX,DELTY:REAL; VAR CODE:INTEGER);
  89.    BEGIN
  90.      CODE := 0;
  91.      IF STKPTR > 1 THEN
  92.         BEGIN
  93.           TRANSMAT := IDMAT;
  94.           TRANSMAT[3,1] := DELTX;
  95.           TRANSMAT[3,2] := DELTY;
  96.           MULMAT(STKMAT[STKPTR-1],TRANSMAT,STKMAT[STKPTR-1]);
  97.         END
  98.       ELSE
  99.         CODE := 1;     (* NOTHING TO TRANSLATE *)
  100.    END;
  101. PROCEDURE ROTATE(THETA:REAL; VAR CODE:INTEGER);
  102.    BEGIN
  103.      CODE := 0;
  104.      IF STKPTR > 1 THEN
  105.         BEGIN
  106.           ROTMAT := IDMAT;
  107.           ROTMAT[1,1] := COS(THETA);
  108.           ROTMAT[1,2] := SIN(THETA);
  109.           ROTMAT[2,1] := -SIN(THETA);
  110.           ROTMAT[2,2] := COS(THETA);
  111.           MULMAT(STKMAT[STKPTR-1],ROTMAT,STKMAT[STKPTR-1]);
  112.         END
  113.       ELSE
  114.         CODE := 1;     (* NOTHING TO ROTATE *)
  115.    END;
  116. PROCEDURE SCALE(XFACT,YFACT:REAL; VAR CODE:INTEGER);
  117.    BEGIN
  118.      CODE := 0;
  119.      IF STKPTR > 1 THEN
  120.         BEGIN
  121.           SCALEMAT := IDMAT;
  122.           SCALEMAT[1,1] := XFACT;
  123.           SCALEMAT[2,2] := YFACT;
  124.           MULMAT(STKMAT[STKPTR-1],SCALEMAT,STKMAT[STKPTR-1]);
  125.         END
  126.       ELSE
  127.         CODE := 1;     (* NOTHING TO SCALE *)
  128.    END;
  129. PROCEDURE MERGE(VAR CODE:INTEGER);
  130.    BEGIN
  131.      CODE := 0;
  132.      IF STKPTR > 2 THEN
  133.         MULMAT(STKMAT[STKPTR-1],STKMAT[STKPTR-2],STKMAT[STKPTR-1])
  134.       ELSE CODE := 1;     (* NOTHING TO MERGE *)
  135.    END;
  136. PROCEDURE MODVEC(VAR XX,YY:REAL; A:MATRIX);
  137.    VAR
  138.      V:VECTOR;
  139.    BEGIN
  140.      V[1] := XX;
  141.      V[2] := YY;
  142.      V[3] := 1.0;
  143.      MULVEC(V,A);
  144.      XX := V[1];
  145.      YY := V[2];
  146.    END;
  147.